home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 1997 February / PC Plus Super CD (Issue 124) (PCP124-2-97) (February 1997).iso / ms / vb5cce / controls / samples / flexlbl / flexlbl.exe / Flexlbl.ctl (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1996-10-25  |  6.7 KB  |  198 lines
  1. VERSION 5.00
  2. Begin VB.UserControl FlexLabel 
  3.    ClientHeight    =   660
  4.    ClientLeft      =   0
  5.    ClientTop       =   0
  6.    ClientWidth     =   1500
  7.    BeginProperty Font 
  8.       Name            =   "Tahoma"
  9.       Size            =   8.4
  10.       Charset         =   0
  11.       Weight          =   400
  12.       Underline       =   0   'False
  13.       Italic          =   0   'False
  14.       Strikethrough   =   0   'False
  15.    EndProperty
  16.    PropertyPages   =   "FlexLbl.ctx":0000
  17.    ScaleHeight     =   660
  18.    ScaleWidth      =   1500
  19.    ToolboxBitmap   =   "FlexLbl.ctx":0004
  20.    Begin VB.Label lblInfo 
  21.       Height          =   375
  22.       Left            =   120
  23.       TabIndex        =   0
  24.       Top             =   120
  25.       Width           =   1215
  26.    End
  27. Attribute VB_Name = "FlexLabel"
  28. Attribute VB_GlobalNameSpace = False
  29. Attribute VB_Creatable = True
  30. Attribute VB_PredeclaredId = False
  31. Attribute VB_Exposed = True
  32. '   FlexLabel Control
  33. '   VB Component Team
  34. '   Microsoft Corporation
  35. '   October 1996
  36. Option Explicit
  37. 'Constant for TrueType check
  38. Private Const TMPF_TRUETYPE = &H4
  39. 'UDT for TrueType check
  40. Private Type TEXTMETRIC
  41.         tmHeight            As Long
  42.         tmAscent            As Long
  43.         tmDescent           As Long
  44.         tmInternalLeading   As Long
  45.         tmExternalLeading   As Long
  46.         tmAveCharWidth      As Long
  47.         tmMaxCharWidth      As Long
  48.         tmWeight            As Long
  49.         tmOverhang          As Long
  50.         tmDigitizedAspectX  As Long
  51.         tmDigitizedAspectY  As Long
  52.         tmFirstChar         As Byte
  53.         tmLastChar          As Byte
  54.         tmDefaultChar       As Byte
  55.         tmBreakChar         As Byte
  56.         tmItalic            As Byte
  57.         tmUnderlined        As Byte
  58.         tmStruckOut         As Byte
  59.         tmPitchAndFamily    As Byte
  60.         tmCharSet           As Byte
  61. End Type
  62. 'API declare for TrueType check
  63. Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
  64. Enum FlexLabelErr
  65.     errNonTrueTypeFont
  66. End Enum
  67. 'Default Property Values
  68. Const m_def_Caption = "FlexLabel"
  69. 'Property Variables
  70. Dim m_Caption               As String
  71. Dim ChangeInProgress        As Boolean
  72. 'Initialize Properties for User Control
  73. Private Sub UserControl_InitProperties()
  74.     ChangeInProgress = False
  75.     lblInfo.Caption = UserControl.Name
  76. End Sub
  77. Private Sub UserControl_Resize()
  78.     If ChangeInProgress = False Then
  79.         ChangeInProgress = True
  80.         
  81. '       --- Set height of text to match box
  82.         With lblInfo
  83.           If TextHeight(.Caption) > Height Then
  84.               While (TextHeight(.Caption) > Height)
  85.                   FontSize = FontSize - 1
  86.               Wend
  87.           ElseIf TextHeight(.Caption) < Height Then
  88.               While (TextHeight(.Caption) < Height)
  89.                   FontSize = FontSize + 1
  90.               Wend
  91.               FontSize = FontSize - 1
  92.           End If
  93.           
  94.           .FontSize = FontSize
  95.           
  96.   '       --- Set width of box to match text
  97.           If Len(.Caption) = 0 Then
  98.               Width = 100
  99.           Else
  100.               Width = TextWidth(.Caption)
  101.           End If
  102.           
  103.           .Move 0, 0, ScaleWidth, ScaleHeight
  104.         End With  'lblInfo
  105.         
  106.         ChangeInProgress = False
  107.     End If
  108. End Sub
  109. 'Load property values from storage
  110. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  111.     lblInfo.Caption = PropBag.ReadProperty("Caption", "FlexLabel")
  112.   lblInfo.ToolTipText = PropBag.ReadProperty("ToolTipText", "")
  113. End Sub
  114. 'Write property values to storage
  115. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  116.     Call PropBag.WriteProperty("Caption", lblInfo.Caption, "FlexLabel")
  117.   Call PropBag.WriteProperty("ToolTipText", lblInfo.ToolTipText, "")
  118. End Sub
  119. Public Property Get Font() As Font
  120. Attribute Font.VB_Description = "Returns a Font object."
  121. Attribute Font.VB_UserMemId = -512
  122.     Set Font = lblInfo.Font
  123. End Property
  124. Public Property Set Font(ByVal New_Font As Font)
  125.     Dim tmpFont As Font
  126.         
  127.     Set tmpFont = lblInfo.Font
  128.     Set UserControl.Font = New_Font
  129.     If IsTrueType(UserControl.hdc) Then
  130. '       Update control with new font informaton
  131.         lblInfo.Font = New_Font
  132.         
  133.         With lblInfo.Font
  134.           .Bold = New_Font.Bold
  135.           .Italic = New_Font.Italic
  136.           .Strikethrough = New_Font.Strikethrough
  137.           .Underline = New_Font.Underline
  138.           .Weight = New_Font.Weight
  139.         End With  'lblInfo.Font
  140.           
  141.         UserControl_Resize
  142.     Else
  143. '       Report error and reset font
  144.         ErrorInfo (errNonTrueTypeFont)
  145.         Set UserControl.Font = tmpFont
  146.     End If
  147. End Property
  148. Public Property Get Caption() As String
  149. Attribute Caption.VB_Description = "Returns/sets the text displayed in an object's title bar or below an object's icon."
  150.     Caption = lblInfo.Caption
  151. End Property
  152. Public Property Let Caption(ByVal New_Caption As String)
  153.     lblInfo.Caption = New_Caption
  154. '   Update control with new text information
  155.     UserControl_Resize
  156.     PropertyChanged "Caption"
  157. End Property
  158. Private Function IsTrueType(phDC As Long) As Boolean
  159.     Dim lRet As Long
  160.     Dim pMETRIC As TEXTMETRIC
  161.     lRet = GetTextMetrics(phDC, pMETRIC)
  162.     If (pMETRIC.tmPitchAndFamily And TMPF_TRUETYPE) > 0 Then
  163.         IsTrueType = True
  164.     Else
  165.         IsTrueType = False
  166.     End If
  167. End Function
  168. Public Sub ErrorInfo(MyErrNumber As FlexLabelErr)
  169.     Const ErrLocation As String = "FlexLabel Control"
  170.     Dim lStr As String
  171.     Select Case MyErrNumber
  172.         Case errNonTrueTypeFont
  173.             lStr = "An attempt was made to set the control font to a " & _
  174.                    "non TrueType font.  The control font remains unchanged."
  175.             
  176.             If Ambient.UserMode Then
  177.                 Err.Raise vbObjectError + errNonTrueTypeFont, _
  178.                           UserControl.Name, lStr
  179.             Else
  180.                 MsgBox lStr, vbOKOnly + vbExclamation, ErrLocation
  181.             End If
  182.         Case Else
  183.             With Err
  184.               .Raise .Number, .Source, .Description
  185.             End With  'Err
  186.     End Select
  187. End Sub
  188. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  189. 'MappingInfo=lblInfo,lblInfo,-1,ToolTipText
  190. Public Property Get ToolTipText() As String
  191. Attribute ToolTipText.VB_Description = "Returns/sets the text displayed when the mouse is paused over the control."
  192.   ToolTipText = lblInfo.ToolTipText
  193. End Property
  194. Public Property Let ToolTipText(ByVal New_ToolTipText As String)
  195.   lblInfo.ToolTipText = New_ToolTipText
  196.   PropertyChanged "ToolTipText"
  197. End Property
  198.